home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / srfi / srfi-37.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  8.3 KB  |  231 lines
  1. ;;; srfi-37.scm --- args-fold
  2.  
  3. ;;     Copyright (C) 2007, 2008 Free Software Foundation, Inc.
  4. ;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;;
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;;
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18.  
  19.  
  20. ;;; Commentary:
  21. ;;
  22. ;; To use this module with Guile, use (cdr (program-arguments)) as
  23. ;; the ARGS argument to `args-fold'.  Here is a short example:
  24. ;;
  25. ;;  (args-fold (cdr (program-arguments))
  26. ;;         (let ((display-and-exit-proc
  27. ;;            (lambda (msg)
  28. ;;              (lambda (opt name arg)
  29. ;;                (display msg) (quit) (values)))))
  30. ;;           (list (option '(#\v "version") #f #f
  31. ;;                 (display-and-exit-proc "Foo version 42.0\n"))
  32. ;;             (option '(#\h "help") #f #f
  33. ;;                 (display-and-exit-proc
  34. ;;                  "Usage: foo scheme-file ..."))))
  35. ;;         (lambda (opt name arg)
  36. ;;           (error "Unrecognized option `~A'" name))
  37. ;;         (lambda (op) (load op) (values)))
  38. ;;
  39. ;;; Code:
  40.  
  41.  
  42. ;;;; Module definition & exports
  43. (define-module (srfi srfi-37)
  44.   #:use-module (srfi srfi-9)
  45.   #:export (option option-names option-required-arg?
  46.         option-optional-arg? option-processor
  47.         args-fold))
  48.  
  49. (cond-expand-provide (current-module) '(srfi-37))
  50.  
  51. ;;;; args-fold and periphery procedures
  52.  
  53. ;;; An option as answered by `option'.  `names' is a list of
  54. ;;; characters and strings, representing associated short-options and
  55. ;;; long-options respectively that should use this option's
  56. ;;; `processor' in an `args-fold' call.
  57. ;;;
  58. ;;; `required-arg?' and `optional-arg?' are mutually exclusive
  59. ;;; booleans and indicate whether an argument must be or may be
  60. ;;; provided.  Besides the obvious, this affects semantics of
  61. ;;; short-options, as short-options with a required or optional
  62. ;;; argument cannot be followed by other short options in the same
  63. ;;; program-arguments string, as they will be interpreted collectively
  64. ;;; as the option's argument.
  65. ;;;
  66. ;;; `processor' is called when this option is encountered.  It should
  67. ;;; accept the containing option, the element of `names' (by `equal?')
  68. ;;; encountered, the option's argument (or #f if none), and the seeds
  69. ;;; as variadic arguments, answering the new seeds as values.
  70. (define-record-type srfi-37:option
  71.   (option names required-arg? optional-arg? processor)
  72.   option?
  73.   (names option-names)
  74.   (required-arg? option-required-arg?)
  75.   (optional-arg? option-optional-arg?)
  76.   (processor option-processor))
  77.  
  78. (define (error-duplicate-option option-name)
  79.   (scm-error 'program-error "args-fold"
  80.          "Duplicate option name `~A~A'"
  81.          (list (if (char? option-name) #\- "--")
  82.            option-name)
  83.          #f))
  84.  
  85. (define (build-options-lookup options)
  86.   "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
  87. to the containing options, signalling an error if a name is
  88. encountered more than once."
  89.   (let ((lookup (make-hash-table (* 2 (length options)))))
  90.     (for-each
  91.      (lambda (opt)
  92.        (for-each (lambda (name)
  93.            (let ((assoc (hash-create-handle!
  94.                  lookup name #f)))
  95.              (if (cdr assoc)
  96.              (error-duplicate-option (car assoc))
  97.              (set-cdr! assoc opt))))
  98.          (option-names opt)))
  99.      options)
  100.     lookup))
  101.  
  102. (define (args-fold args options unrecognized-option-proc
  103.            operand-proc . seeds)
  104.   "Answer the results of folding SEEDS as multiple values against the
  105. program-arguments in ARGS, as decided by the OPTIONS'
  106. `option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
  107.   (let ((lookup (build-options-lookup options)))
  108.     ;; I don't like Guile's `error' here
  109.     (define (error msg . args)
  110.       (scm-error 'misc-error "args-fold" msg args #f))
  111.  
  112.     (define (mutate-seeds! procedure . params)
  113.       (set! seeds (call-with-values
  114.               (lambda ()
  115.             (apply procedure (append params seeds)))
  116.             list)))
  117.  
  118.     ;; Clean up the rest of ARGS, assuming they're all operands.
  119.     (define (rest-operands)
  120.       (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
  121.         args)
  122.       (set! args '()))
  123.  
  124.     ;; Call OPT's processor with OPT, NAME, an argument to be decided,
  125.     ;; and the seeds.  Depending on OPT's *-arg? specification, get
  126.     ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
  127.     ;; if no argument is allowed, call NO-ARG-PROC thunk.
  128.     (define (invoke-option-processor
  129.          opt name req-arg-proc opt-arg-proc no-arg-proc)
  130.       (mutate-seeds!
  131.        (option-processor opt) opt name
  132.        (cond ((option-required-arg? opt) (req-arg-proc))
  133.          ((option-optional-arg? opt) (opt-arg-proc))
  134.          (else (no-arg-proc) #f))))
  135.  
  136.     ;; Compute and answer a short option argument, advancing ARGS as
  137.     ;; necessary, for the short option whose character is at POSITION
  138.     ;; in the current ARG.
  139.     (define (short-option-argument position)
  140.       (cond ((< (1+ position) (string-length (car args)))
  141.          (let ((result (substring (car args) (1+ position))))
  142.            (set! args (cdr args))
  143.            result))
  144.         ((pair? (cdr args))
  145.          (let ((result (cadr args)))
  146.            (set! args (cddr args))
  147.            result))
  148.         (else #f)))
  149.  
  150.     ;; Interpret the short-option at index POSITION in (car ARGS),
  151.     ;; followed by the remaining short options in (car ARGS).
  152.     (define (short-option position)
  153.       (if (>= position (string-length (car args)))
  154.           (begin
  155.             (set! args (cdr args))
  156.             (next-arg))
  157.       (let* ((opt-name (string-ref (car args) position))
  158.          (option-here (hash-ref lookup opt-name)))
  159.         (cond ((not option-here)
  160.            (mutate-seeds! unrecognized-option-proc
  161.                   (option (list opt-name) #f #f
  162.                       unrecognized-option-proc)
  163.                   opt-name #f)
  164.            (short-option (1+ position)))
  165.           (else
  166.            (invoke-option-processor
  167.             option-here opt-name
  168.             (lambda ()
  169.               (or (short-option-argument position)
  170.               (error "Missing required argument after `-~A'" opt-name)))
  171.             (lambda ()
  172.               ;; edge case: -xo -zf or -xo -- where opt-name=#\o
  173.               ;; GNU getopt_long resolves these like I do
  174.               (short-option-argument position))
  175.             (lambda () #f))
  176.            (if (not (or (option-required-arg? option-here)
  177.                 (option-optional-arg? option-here)))
  178.                (short-option (1+ position))))))))
  179.  
  180.     ;; Process the long option in (car ARGS).  We make the
  181.     ;; interesting, possibly non-standard assumption that long option
  182.     ;; names might contain #\=, so keep looking for more #\= in (car
  183.     ;; ARGS) until we find a named option in lookup.
  184.     (define (long-option)
  185.       (let ((arg (car args)))
  186.     (let place-=-after ((start-pos 2))
  187.       (let* ((index (string-index arg #\= start-pos))
  188.          (opt-name (substring arg 2 (or index (string-length arg))))
  189.          (option-here (hash-ref lookup opt-name)))
  190.         (if (not option-here)
  191.         ;; look for a later #\=, unless there can't be one
  192.         (if index
  193.             (place-=-after (1+ index))
  194.             (mutate-seeds!
  195.              unrecognized-option-proc
  196.              (option (list opt-name) #f #f unrecognized-option-proc)
  197.              opt-name #f))
  198.         (invoke-option-processor
  199.          option-here opt-name
  200.          (lambda ()
  201.            (if index
  202.                (substring arg (1+ index))
  203.                (error "Missing required argument after `--~A'" opt-name)))
  204.          (lambda () (and index (substring arg (1+ index))))
  205.          (lambda ()
  206.            (if index
  207.                (error "Extraneous argument after `--~A'" opt-name))))))))
  208.       (set! args (cdr args)))
  209.  
  210.     ;; Process the remaining in ARGS.  Basically like calling
  211.     ;; `args-fold', but without having to regenerate `lookup' and the
  212.     ;; funcs above.
  213.     (define (next-arg)
  214.       (if (null? args)
  215.       (apply values seeds)
  216.       (let ((arg (car args)))
  217.         (cond ((or (not (char=? #\- (string-ref arg 0)))
  218.                (= 1 (string-length arg))) ;"-"
  219.            (mutate-seeds! operand-proc arg)
  220.            (set! args (cdr args)))
  221.           ((char=? #\- (string-ref arg 1))
  222.            (if (= 2 (string-length arg)) ;"--"
  223.                (begin (set! args (cdr args)) (rest-operands))
  224.                (long-option)))
  225.           (else (short-option 1)))
  226.         (next-arg))))
  227.  
  228.     (next-arg)))
  229.  
  230. ;;; srfi-37.scm ends here
  231.